Raport ma na celu przeanalizowanie oraz interpretacje bazy danych Lego na przestrzeni lat.
Z roku na rok na rynku możemy zauważyć coraz bardziej rozmaite zestawy klocków Lego. Dlatego też analizie poddano elementy związane z zestawami, figurkami oraz poszczególnymi częściami. W raporcie skupiono się na trendach rozwojowych w tej kategorii produktów, badając zmiany w ilości dostępnych tematyk, rozbudowie zestawów, a także w użyciu figurek i różnorodności części.
Analiza danych obejmuje lata 1980-2023 i uwydatnia ewolucję Lego, zarówno pod kątem liczby produktów, jak i ich złożoności. Zbiór danych został uproszczony do obiektów reprezentujących zestawy z klockami (posiadającymi jakieś części).
Zbiór danych został poddany analizie korelacji, dzięki czemu wyróżniono istotne związki pomiędzy różnymi atrybutami, takimi jak rok produkcji, liczba używanych figurek, czy złożoność zestawów. Korelacje te dostarczają głębszego zrozumienia dynamiki rozwoju produktów Lego na przestrzeni lat.
Ostatnim elementem analizy jest sekcja próbująca przewidzieć złożoność zestawów Lego, w tym celu użyto algorytmu uczenia maszynowego Random Forest. Na tej podstawie można wyciągnać wniosek, że największy wpływ na to mają upływający czas oraz ilość figurek.
Dla zapewnienia powtarzalności wyników przy każdym uruchomieniu raportu dla tych samych danych, ustawiono ziarno dla generatora liczb pseudolosowych.
set.seed(23)
Raport został stworzony przy wykorzystaniu następujących bibliotek.
library(dplyr)
library(ggplot2)
library(tidyr)
library(tibble)
library(plotly)
library(gganimate)
library(caret)
library(randomForest)
colors <- read.csv("dataset/colors.csv")
parts_cat <- read.csv("dataset/part_categories.csv")
elements <- read.csv("dataset/elements.csv")
parts <- read.csv("dataset/parts.csv")
inv_parts <- read.csv("dataset/inventory_parts.csv")
figs <- read.csv("dataset/minifigs.csv")
inv_figs <- read.csv("dataset/inventory_minifigs.csv")
themes <- read.csv("dataset/themes.csv")
sets <- read.csv("dataset/sets.csv")
inv_sets <- read.csv("dataset/inventory_sets.csv")
inventories <- read.csv("dataset/inventories.csv")
Ta sekcja poświęcona jest przetworzeniu brakujących wartości oraz transformacji wykorzystanych zbiorów danych.
Pierwsza i bardzo ważna część badanego zbioru danych. Zawierają się w niej informacje o zestawach Lego, takie jak: rok wydania, ilość części w zestawie oraz lata w jakich dany zestaw zadebiutował na rynku.
sets <- sets %>% filter(num_parts > 0)
themes <- setNames(themes, c("theme_id", "theme_name", "parent_id"))
colnames(sets)[colnames(sets) == "name"] <- "set_name"
colnames(sets)[colnames(sets) == "num_parts"] <- "set_num_parts"
colnames(inv_sets)[colnames(inv_sets) == "quantity"] <- "set_qty"
sets_with_themes <- themes %>%
merge(sets, by = "theme_id") %>%
select(-c("theme_id","img_url","parent_id"))
Na wykresach można zaobserwować pewien trend. Wskazuje on na to, że wraz z upływem czasu powstaje coraz więcej zestawów Lego. Dodatkowo są one coraz większe i bardziej rozbudowane, na co wskazuje rosnąca liczba części.
unique_theme_data <- sets_with_themes %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(unique_theme = n_distinct(theme_name, na.rm = TRUE))
ggplot(unique_theme_data , aes(x = year, y = unique_theme)) +
geom_line(aes(y = unique_theme, color = "Unikalne tematyki zestawów"), size = 1) +
labs(x = "Rok", y = "Liczba tematyk", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
mean_nparts_data <- sets_with_themes %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(sets_mean_nparts = mean(set_num_parts, na.rm = TRUE), sets_count = n())
ggplot(mean_nparts_data , aes(x = year, y = sets_mean_nparts)) +
ggtitle("Średnia liczba części w zestawach w latach 1980-2023") +
geom_bar(stat="identity", fill = "#fc8d62") +
labs(x = "Rok", y = "Liczba części") +
theme_bw()
knitr::kable(summary(sets_with_themes), caption = "Podstawowe statystyki - zestawy Lego")
| theme_name | set_num | set_name | year | set_num_parts | |
|---|---|---|---|---|---|
| Length:17231 | Length:17231 | Length:17231 | Min. :1949 | Min. : 1.0 | |
| Class :character | Class :character | Class :character | 1st Qu.:1999 | 1st Qu.: 18.0 | |
| Mode :character | Mode :character | Mode :character | Median :2011 | Median : 54.0 | |
| Mean :2006 | Mean : 204.9 | ||||
| 3rd Qu.:2017 | 3rd Qu.: 203.0 | ||||
| Max. :2023 | Max. :11695.0 |
Kolejna część badanego zbioru danych. Możemy znaleźć w niej informacje o figurkach m.in. z czego się składają.
colnames(figs)[colnames(figs) == "name"] <- "fig_name"
colnames(figs)[colnames(figs) == "num_parts"] <- "fig_num_parts"
colnames(inv_figs)[colnames(inv_figs) == "quantity"] <- "fig_qty"
colnames(inventories)[colnames(inventories) == "id"] <- "inventory_id"
inventory_minifigures <- inv_figs %>%
merge(figs, by = "fig_num") %>%
merge(inventories, by = "inventory_id") %>%
merge(sets, by = "set_num") %>%
select(-c(1:2, 7:9, 11:13))
Jeśli chodzi o ilość wykorzystywanych w zestawach figurek to możemy zauważyć, że z czasem pojawiają się coraz częściej.
figures_number <- inventory_minifigures %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(fig_count = n())
ggplot(figures_number , aes(x = year, y = fig_count)) +
geom_line(aes(y = fig_count, color = "Liczba figurek"), size = 1) +
labs(x = "Rok", y = "Liczba figurek", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
knitr::kable(summary(inventory_minifigures), caption = "Podstawowe statystyki - figurki Lego")
| fig_num | fig_qty | fig_name | fig_num_parts | year | |
|---|---|---|---|---|---|
| Length:20817 | Min. : 1.000 | Length:20817 | Min. : 1.000 | Min. :1975 | |
| Class :character | 1st Qu.: 1.000 | Class :character | 1st Qu.: 4.000 | 1st Qu.:2006 | |
| Mode :character | Median : 1.000 | Mode :character | Median : 4.000 | Median :2014 | |
| Mean : 1.062 | Mean : 4.814 | Mean :2011 | |||
| 3rd Qu.: 1.000 | 3rd Qu.: 5.000 | 3rd Qu.:2019 | |||
| Max. :100.000 | Max. :143.000 | Max. :2023 |
Ostatania część badanego zestawu danych zawiera informacje na temat części Lego. Znajdują się w niej szczegóły poszczególnych części: elementy z których się składają, kolor, materiał z którego zostały wykonane oraz kategoria do której przynależą.
colnames(parts)[colnames(parts) == "name"] <- "part_name"
colnames(parts_cat)[colnames(parts_cat) == "name"] <- "part_cat_name"
colnames(parts_cat)[colnames(parts_cat) == "id"] <- "part_cat_id"
colnames(colors)[colnames(colors) == "name"] <- "color_name"
colnames(colors)[colnames(colors) == "id"] <- "color_id"
colnames(inv_parts)[colnames(inv_parts) == "quantity"] <- "part_qty"
element_counts <- elements %>%
group_by(part_num, color_id) %>%
summarise(el_per_part = n())
inventory_parts <- inv_parts %>%
merge(parts, by = "part_num") %>%
merge(colors, by = "color_id") %>%
merge(parts_cat, by = "part_cat_id") %>%
merge(element_counts, by = c("part_num", "color_id")) %>%
merge(inventories, by = "inventory_id") %>%
merge(sets, by = "set_num") %>%
select(-c(1:2, 4, 7:8, 12, 16:17, 19:21))
W przypadku części Lego również można dostrzec pewne trendy. Wykorzystywane elementy są coraz bardziej zróżnicowane, poprzez tworzenie części z nowych materiałów oraz w nowych kolorach. Warte wyróżnienia jest, że złożoność części się nie zmieniła (na jedną część średnio przypada 1.6 elementu)
transparent_parts <- inventory_parts %>%
group_by(is_trans) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(trans_part_count = n())
ggplot(transparent_parts, aes(x=is_trans, y=trans_part_count, fill=is_trans)) +
geom_bar(stat="identity", position="dodge") +
scale_fill_manual(values = c("t" = "#66c2a5", "f" = "#fc8d62"), labels = c("TAK", "NIE")) +
scale_x_discrete(labels = c("t" = "TAK", "f" = "NIE")) +
labs(title = "Zestawienie kolorów (transparentność)", x = "Transparentność", y = "Liczba obserwacji", fill = "Legenda") +
theme_bw()
unique_data <- inventory_parts %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
group_by(year, part_material) %>%
summarise(count = n(), type = "Material") %>%
bind_rows(
inventory_parts %>%
group_by(year, color_name) %>%
summarise(count = n(), type = "Color") %>%
bind_rows(
inventory_parts %>%
group_by(year, part_cat_name) %>%
summarise(count = n(), type = "Category")
)
)
ggplot(unique_data, aes(x = year, y = count, fill = type)) +
geom_bar(stat = "identity", position = "dodge") +
facet_grid(type ~ ., scales = "free_y", labeller = labeller(type = c("Material" = "Materiały", "Color" = "Kolory", "Category" = "Kategorie"))) +
scale_fill_manual(values = c("Category" = "#66c2a5", "Color" = "#fc8d62", "Material" = "#8da0cb"), labels = c("Kategorie", "Kolory", "Materiały")) +
labs(x = "Rok", y = "Liczba obserwacji", fill = "Legenda") +
theme_bw()
elements_count <- inventory_parts %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(el_in_part = mean(el_per_part, na.rm = TRUE))
ggplot(elements_count , aes(x = year, y = el_in_part)) +
geom_line(aes(color = "Średnia ilość elementów w częściach"), size = 1) +
labs(x = "Rok", y = "Liczba elementów", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
knitr::kable(summary(inventory_parts), caption = "Podstawowe statystyki - części Lego")
| part_num | part_cat_id | part_qty | part_name | part_material | color_name | is_trans | part_cat_name | el_per_part | year | |
|---|---|---|---|---|---|---|---|---|---|---|
| Length:1040178 | Min. : 1.00 | Min. : 1.000 | Length:1040178 | Length:1040178 | Length:1040178 | Length:1040178 | Length:1040178 | Min. :1.000 | Min. :1954 | |
| Class :character | 1st Qu.:11.00 | 1st Qu.: 1.000 | Class :character | Class :character | Class :character | Class :character | Class :character | 1st Qu.:1.000 | 1st Qu.:2008 | |
| Mode :character | Median :15.00 | Median : 2.000 | Mode :character | Mode :character | Mode :character | Mode :character | Mode :character | Median :1.000 | Median :2016 | |
| Mean :21.73 | Mean : 3.566 | Mean :1.591 | Mean :2013 | |||||||
| 3rd Qu.:28.00 | 3rd Qu.: 4.000 | 3rd Qu.:2.000 | 3rd Qu.:2020 | |||||||
| Max. :68.00 | Max. :3064.000 | Max. :9.000 | Max. :2023 |
dataset <- unique_theme_data %>%
merge(mean_nparts_data) %>%
merge(figures_number) %>%
merge(transparent_parts) %>%
merge(elements_count)
knitr::kable(summary(dataset))
| year | unique_theme | sets_mean_nparts | sets_count | fig_count | is_trans | trans_part_count | el_in_part | |
|---|---|---|---|---|---|---|---|---|
| Min. :1980 | Min. :14.00 | Min. : 66.47 | Min. : 72.0 | Min. : 48.0 | Length:88 | Min. : 61979 | Min. :1.426 | |
| 1st Qu.:1991 | 1st Qu.:23.75 | 1st Qu.:108.15 | 1st Qu.:153.2 | 1st Qu.: 135.2 | Class :character | 1st Qu.: 61979 | 1st Qu.:1.588 | |
| Median :2002 | Median :51.00 | Median :156.56 | Median :341.0 | Median : 289.0 | Mode :character | Median :513332 | Median :1.610 | |
| Mean :2002 | Mean :49.16 | Mean :175.58 | Mean :364.5 | Mean : 467.2 | Mean :513332 | Mean :1.598 | ||
| 3rd Qu.:2012 | 3rd Qu.:69.50 | 3rd Qu.:225.65 | 3rd Qu.:544.0 | 3rd Qu.: 855.5 | 3rd Qu.:964684 | 3rd Qu.:1.638 | ||
| Max. :2023 | Max. :90.00 | Max. :412.85 | Max. :761.0 | Max. :1296.0 | Max. :964684 | Max. :1.662 |
W tej sekcji przedstawiono jak na przestrzeni lat (1980-2023) zmieniały się trendy w Lego. Uwzględniono zmiany w złożoności zestawów (średniej liczby wykorzystywanych w nich części) poprzez wielkość punktu, w porównaniu z ilością wykorzystywanych w zestawach figurek oraz liczby dostępnych zestawów.
Na podstawie wykresu możemy zauważyć, że największy przeskok jeśli chodzi o zaawansowanie zestawów (ich ilość i złożoność), przypada na okres około 2010 roku.
animation <- dataset %>%
select(year, sets_count, fig_count, sets_mean_nparts)
p <- ggplot(animation, aes(x=sets_count, y=fig_count, size = sets_mean_nparts)) +
geom_point(show.legend = FALSE, alpha = 0.8, color = "#fc8d62") +
labs(title = 'Rok: {frame_time}', x = "Liczba dostępnych zestawów", y = "Ilość wykorzystywanych figurek") +
transition_time(year) +
theme_bw()
animate(p, nframes = 225)
Na poniższym wykresie przedstawiona została wartość współczynnika korelacji Pearsona między parametrami atrybutów w zbiorze.
W tabeli przedstawiono wartości współczynnika korelacji dla poszczególnych par atrybutów.
| Wiersz | Kolumna | Współczynnik korelacji |
|---|---|---|
| unique_theme | year | 0.9546391 |
| sets_count | unique_theme | 0.9500207 |
| fig_count | sets_count | 0.9461115 |
| sets_count | year | 0.9394910 |
| fig_count | year | 0.9279022 |
| fig_count | unique_theme | 0.9105042 |
| sets_mean_nparts | year | 0.8495637 |
| fig_count | sets_mean_nparts | 0.8277278 |
| sets_count | sets_mean_nparts | 0.7334811 |
| sets_mean_nparts | unique_theme | 0.7245879 |
| el_in_part | unique_theme | 0.3022160 |
| el_in_part | year | 0.2540180 |
| el_in_part | sets_count | 0.1396989 |
| el_in_part | sets_mean_nparts | -0.0813053 |
| el_in_part | fig_count | 0.0291011 |
| sets_mean_nparts | trans_part_count | 0.0000000 |
| sets_count | trans_part_count | 0.0000000 |
| fig_count | trans_part_count | 0.0000000 |
| trans_part_count | year | 0.0000000 |
| trans_part_count | unique_theme | 0.0000000 |
| el_in_part | trans_part_count | 0.0000000 |
Wnioski wyciągnięte na podstawie obliczeń współczynnika korelacji:
W tej sekcji opisano wykorzystanie uczenia maszynowego do prognozowania złożoności zestawów Lego, czyli średniej liczby ich części. Do tego celu użyto algorytmu Random Forest, z zastosowaniem metody losowania ze zwracaniem (bootstraping).
dataset$is_trans <- as.factor(dataset$is_trans)
inTraining <-
createDataPartition(
y = dataset$sets_mean_nparts,
p = .7,
list = FALSE)
training <- dataset[inTraining,]
testing <- dataset[-inTraining,]
Przygotowano schemat uczenia wraz z optymalizacją parametrów modelu. Najlepszy model został stworzony dla parametru liczby zmiennych losowo wybranych jako kandydaci w każdym podziale (mtry) równego 7. Poza tym wybrany model charakteryzuje się najniższym błędem średniokwadratowym (RMSE), który wynosi 24.44512. Dodatkowo miara dopasowania modelu do danych (Rsquared) również jest też najwyższa.
rfGrid <- expand.grid(mtry = 2:20)
gridCtrl <- trainControl(method = "boot", number = 100)
fitTune <- train(sets_mean_nparts ~ .,
data = training,
method = "rf",
trControl = gridCtrl,
tuneGrid = rfGrid,
ntree = 40)
fitTune
## Random Forest
##
## 64 samples
## 7 predictor
##
## No pre-processing
## Resampling: Bootstrapped (100 reps)
## Summary of sample sizes: 64, 64, 64, 64, 64, 64, ...
## Resampling results across tuning parameters:
##
## mtry RMSE Rsquared MAE
## 2 29.16485 0.8988941 22.91078
## 3 26.00530 0.9139084 19.79199
## 4 24.67108 0.9235214 18.79547
## 5 25.12532 0.9208001 19.13988
## 6 25.06607 0.9209305 19.02791
## 7 24.44512 0.9240855 18.59438
## 8 24.59383 0.9230282 18.63861
## 9 24.73483 0.9220767 18.75369
## 10 24.83435 0.9209057 18.85592
## 11 25.16977 0.9191875 19.00527
## 12 24.75590 0.9220630 18.89430
## 13 25.00818 0.9205321 18.96919
## 14 24.91438 0.9210614 18.92374
## 15 24.93358 0.9207246 18.82868
## 16 25.00278 0.9212167 18.93892
## 17 24.69690 0.9220072 18.73967
## 18 24.70791 0.9220882 18.68116
## 19 24.72770 0.9228712 18.73315
## 20 25.01388 0.9213432 18.97987
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was mtry = 7.
predictions <- predict(fitTune, newdata = testing)
important_df <- data.frame(importance(fitTune$finalModel))
important_df$names <- rownames(important_df)
ggplot(important_df, aes(x=names, y=IncNodePurity/1000)) +
geom_bar(stat="identity", fill = "#fc8d62") +
labs(title = "Wykres ważności atrybutów w podejmowaniu decyzji", x="Atrybuty", y="Ważność") +
theme_bw() +
theme(axis.text.x = element_text(angle = 45, hjust=1))
Na podstawie powyższego wykresu okazuje się, że najważniejszymi atrybutami są:
compare_df <- testing %>% select(year, sets_mean_nparts)
compare_df$Predict <- predictions
ggplot(compare_df, aes(x = year)) +
geom_line(aes(y = sets_mean_nparts, color = "Rzeczywista liczba części"), size = 1) +
geom_line(aes(y = Predict, color = "Przewidywana liczba części"), size = 1) +
labs(x = "Rok", y = "Średnia liczba części w zestawie") +
scale_color_manual(name = "Legenda", values = c("Rzeczywista liczba części" = "#fc8d62", "Przewidywana liczba części" = "#8da0cb")) +
theme_bw()